home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / symbol.t < prev    next >
Text File  |  1988-02-05  |  7KB  |  186 lines
  1. (herald symbol
  2.   (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; general symbol table stuff.
  28.  
  29. (lset *symbol-delimiter* '#f) ;++ should we initialize it?
  30.  
  31. (define-constant %%symbol-text-offset 4)
  32.  
  33. (define-integrable (symbol-print-length sym)
  34.   (fx- (symbol-length sym) %%symbol-text-offset))
  35.  
  36. (define the-symbols                   ; local
  37.   (vector-fill (make-vector 2039) '()))    ; 2039 is prime
  38.  
  39.  
  40. (define (compare-string-to-symbol string symbol)
  41.   (let ((strlen (string-length string))
  42.         (symlen (symbol-length symbol)))
  43.     (if (fx= strlen (fx- symlen %%symbol-text-offset))
  44.         (iterate loop ((i 0) (j %%symbol-text-offset))
  45.           (cond ((fx>= i strlen) '#t)
  46.                 ((charN= (string-elt string i) (symbol-elt symbol j))
  47.                  '#f)
  48.                 (else
  49.                  (loop (fx+ i 1) (fx+ j 1)))))
  50.         '#f)))
  51.  
  52. ;;; intern, v.t. to confine or impound, esp. during a war.  (webster.)
  53.  
  54. ;;; Is interned really useful?
  55.  
  56. (define (interned obj)
  57.   (let ((string (check-arg
  58.                  (lambda (obj)
  59.                    (cond ((symbol? obj) (symbol->string obj)) ;++ can't happen
  60.                          ((string? obj) obj)
  61.                          (else nil)))
  62.                  obj
  63.                  'interned)))
  64.     (intern-1 string '#f)))
  65.  
  66. ;;; integrable because only used in one place.
  67.  
  68. (define-integrable (%make-symbol string hash)
  69.   (let* ((len  (fx+ %%symbol-text-offset (string-length string)))
  70.          (xlen (fx-ashr (fx+ len 3) 2))
  71.          (sym  (make-vector-extend header/symbol len xlen)))
  72.     (iterate loop ((i 0) (j %%symbol-text-offset))
  73.       (cond ((fx< j len)
  74.              (set (symbol-elt sym j) (string-elt string i))
  75.              (loop (fx+ i 1) (fx+ j 1)))
  76.             (else
  77.              (set (symbol-hash sym) hash)
  78.              sym)))))
  79.  
  80. ;++ the fx-rem is slow it should be changed to fx-and
  81. ;++ or maybe use rk's table package
  82.  
  83. (define (intern-1 string create?)
  84.   (let* ((hash   (string-hash string))
  85.          (index (fx-rem hash (vector-length the-symbols)))
  86.          (bucket (vref the-symbols index)))
  87.     (iterate loop ((l bucket))
  88.       (cond ((null? l)
  89.              (if create?
  90.                  (let ((symbol (%make-symbol string hash)))
  91.                    (set (vref the-symbols index)
  92.                         (cons symbol bucket))
  93.                    symbol)
  94.                  '#f))
  95.             ((compare-string-to-symbol string (car l))
  96.              (car l))
  97.             (else (loop (cdr l)))))))
  98.  
  99. ;;; string->symbol uses one (global) symbol table in particular.
  100.                          
  101. (define (string->symbol string)
  102.   (let ((string (enforce string? string)))
  103.     (intern-1 string '#t)))
  104.  
  105. (define (symbol->string symbol)
  106.   (let* ((symbol (enforce symbol? symbol))
  107.          (len    (symbol-length symbol))
  108.          (string (make-string (fx- len 4)))     ; subtract the hash slot
  109.          (text   (string-text string)))
  110.     (iterate loop ((i %%symbol-text-offset) (j 0))
  111.       (cond ((fx>= i len) string)
  112.             (else
  113.              (set (text-elt text j) (symbol-elt symbol i))
  114.              (loop (fx+ i 1) (fx+ j 1)))))))
  115.  
  116.  
  117. ;;; Other stuff
  118.  
  119. (define (increment-generator-count)
  120.   (defer-interrupts
  121.     (set (system-global slink/symbol-generator-count)
  122.          (fx+ (system-global slink/symbol-generator-count) 1))
  123.     (system-global slink/symbol-generator-count)))
  124.  
  125. ;;; Generates a new (not previously interned) symbol using prefix
  126. ;;; which must be a string.
  127.  
  128. (define (generate-symbol prefix)
  129.   (let ((buf (get-buffer)))
  130.     (display prefix buf)  
  131.     (vm-write-char buf #\.)
  132.     (vm-write-fixnum buf (increment-generator-count) 10)
  133.     (let ((str (buffer->string! buf)))
  134.       (cond ((intern-1 str '#f)
  135.              (release-buffer buf)
  136.              (generate-symbol prefix))
  137.             (else
  138.              (let ((val (intern-1 str '#t)))
  139.                (release-buffer buf)
  140.                val))))))
  141.  
  142. ;;; Random utility used by system macros.  Buffers must be available
  143. ;;; in order to use this.
  144.  
  145. (define (concatenate-symbol . things)
  146.   (with-buffers ((buf))
  147.     (do ((z things (cdr z)))
  148.         ((null? z)
  149.          (string->symbol (buffer->string! buf)))
  150.       (display (car z) buf))))
  151.  
  152. (define (walk-symbols proc)
  153.   (walk-vector (lambda (bucket) (walk proc bucket)) the-symbols))
  154.  
  155. ;;; Symbol printing
  156.  
  157. (lset *write-symbol* plain-write-symbol)
  158.  
  159. (define-handler symbol
  160.   (object nil
  161.     ((hash self) (symbol-hash self))
  162.     ((print symbol port)
  163.      (*write-symbol* port symbol))
  164.     ((display symbol port)
  165.      (plain-write-symbol port symbol))))
  166.  
  167. (lset *translate-constituent-inverse* '#f)
  168.  
  169. ;;; Write a vanilla symbol
  170.  
  171. (define (plain-write-symbol port symbol)
  172.   (let ((len    (symbol-length symbol))
  173.         (writec (if (iob? port) vm-write-char write-char)))
  174.     (iterate loop ((i %%symbol-text-offset))
  175.       (cond ((fx>= i len) (no-value))
  176.             (else
  177.              (writec port 
  178.                      (if *translate-constituent-inverse*
  179.                          (*translate-constituent-inverse* (symbol-elt symbol i))
  180.                          (symbol-elt symbol i)))
  181.              (loop (fx+ i 1)))))))
  182.  
  183. ;;; Build the symbol table
  184. ;++ This should move to boot someday,
  185. (initialize-symbol-table)
  186.